home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / cad / acadlsp.zip / 3D.LSP next >
Lisp/Scheme  |  1987-03-07  |  8KB  |  256 lines
  1.  
  2. ; 3D cones, domes, dishes and spheres for AutoCAD 2.6
  3.  
  4. ; by Simon Jones - Autodesk UK Ltd.
  5. ; and Duff Kurland - Autodesk, Inc.
  6. ; November, 1986
  7.  
  8. ; Save system variables
  9. (defun VARGET ()
  10.    (setq elevation-v (getvar "ELEVATION"))
  11.    (setq thickness-v (getvar "THICKNESS"))
  12.    (setq cmdecho-v   (getvar "CMDECHO"))
  13.    (setq blipmode-v  (getvar "BLIPMODE"))
  14.    (setq highlight-v (getvar "HIGHLIGHT"))
  15. )
  16.  
  17. ; Restore system variables
  18. (defun RESETVAR ()
  19.    (setvar "ELEVATION" elevation-v)
  20.    (setvar "THICKNESS" thickness-v)
  21.    (setvar "CMDECHO"   cmdecho-v)
  22.    (setvar "BLIPMODE"  blipmode-v)
  23.    (setvar "HIGHLIGHT" highlight-v)
  24. )
  25.  
  26. ; Convert degrees to radians
  27. (defun DTR (a)
  28.    (* pi (/ a 180.0))
  29. )
  30.  
  31. ; Calculate new radius for dome/dish/sphere
  32. (defun CALC-R (y)
  33.    (sqrt (- (* rad rad) (* y y)))
  34. )
  35.  
  36. ; Select all entities added since checkpoint.
  37. (defun SELSTUFF (e / ss)
  38.    (gc)
  39.    (setq ss (ssadd))                  ; Form empty selection-set
  40.    (if (null e)                       ; No previous stuff in drawing?
  41.        (setq ss (ssadd (setq e (entnext)) ss))  ; Start with what we drew
  42.    )
  43.    (while (setq e (entnext e))        ; Scan until end of drawing
  44.       (setq ss (ssadd e ss))          ; Add each entity to selection-set
  45.    )
  46.    ss                                 ; Return selection-set
  47. )
  48.  
  49. ; Form a 3-point cone face
  50. (defun 3-CONE-SEG ()
  51.    (setq pt2 (polar cen 0.0 max-rad))
  52.    (setq pt3 (polar cen (dtr (/ 360.0 numseg)) max-rad))
  53.    (command "3DFACE"
  54.             (list (car cen) (cadr cen) (+ elev h))
  55.             (list (car pt2) (cadr pt2) elev)
  56.             (list (car pt3) (cadr pt3) elev)
  57.             ""
  58.             ""
  59.    )
  60. )
  61.  
  62. ; Form a 4-point chopped-cone face
  63. (defun 4-CONE-SEG ()
  64.    (setq pt1 (polar cen 0.0 min-rad))
  65.    (setq pt2 (polar cen 0.0 max-rad))
  66.    (setq pt3 (polar cen (dtr (/ 360.0 numseg)) max-rad))
  67.    (setq pt4 (polar cen (dtr (/ 360.0 numseg)) min-rad))
  68.    (command "3DFACE"
  69.             (list (car pt1) (cadr pt1) (+ elev h))
  70.             (list (car pt2) (cadr pt2) elev )
  71.             (list (car pt3) (cadr pt3) elev )
  72.             (list (car pt4) (cadr pt4) (+ elev h))
  73.             ""
  74.    )
  75. )
  76.  
  77. ; Build upper or lower hemisphere from chopped cones
  78. ; with decreasing radii.
  79. (defun HEMISPHERE (which)
  80.    (setq h2 (/ rad 4.0))
  81.    (if (eq which "lower")             ; Doing lower hemisphere?
  82.        (setq h2 (- h2))               ; Yes, use negaitve height
  83.    )
  84.    (setq elev elevation-v h1 0 h (- h2 h1))
  85.    (while (> (* rad rad) (* h2 h2))
  86.           (setq max-rad (calc-r h1) min-rad (calc-r h2) h (- h2 h1))
  87.           (4-cone-seg)
  88.           (setq h1 h2 h2 (+ h2 (* h 0.85)))
  89.           (setq elev (+ elev h) h (- h2 h1))
  90.    )
  91.  
  92.    ; Now top it off.
  93.  
  94.    (setq max-rad (calc-r h1))
  95.    (if (eq which "upper")
  96.       (setq h (- (+ elevation-v rad) elev))
  97.       (setq h (- (- elevation-v rad) elev))
  98.    )
  99.    (3-cone-seg)
  100. )
  101.  
  102. ; Draw a 3D cone
  103. (defun C:CONE (/ cen elev h max-rad min-rad pt2 pt3 rad numseg)
  104.    (varget)
  105.    (setvar "THICKNESS" 0)
  106.    (setvar "CMDECHO"   0)
  107.    (setvar "HIGHLIGHT" 0)
  108.    (setq elev elevation-v)
  109.    (initget (+ 1 16))                 ; Center point - 3D okay, cannot be null
  110.    (setq cen     (getpoint "\nCenter point: "))
  111.    (initget 3)                        ; Height cannot be zero or null
  112.    (setq h       (getdist cen "\nHeight: "))
  113.    (initget 7)                        ; Base radius cannot be zero, neg, null
  114.    (setq max-rad (getdist cen "\nBase radius: "))
  115.    (command "CIRCLE" cen max-rad)
  116.    (initget 4)                        ; Top radius cannot be negative
  117.    (setq min-rad (getdist cen "\nTop radius <0>: "))
  118.    (if (= min-rad 0)
  119.        (setq min-rad nil)
  120.    )
  121.    (if min-rad
  122.        (progn
  123.           (setvar "ELEVATION" (+ elev h))
  124.           (command "CIRCLE" cen min-rad)
  125.           (setvar "ELEVATION" elev)
  126.        )
  127.    )
  128.    (initget 6)                        ; Cannot have zero or negative segs
  129.    (setq numseg (getint "\nNumber of segments <15>: "))
  130.    (if (null numseg)
  131.        (setq numseg 15)
  132.    )
  133.    (setvar "BLIPMODE" 0)
  134.    (if min-rad
  135.        (4-cone-seg)                   ; chopped off point
  136.        (3-cone-seg)                   ; full point
  137.    )
  138.    (command "ARRAY" "Last" "" "Polar" cen numseg "360" "")
  139.    (resetvar)
  140.    (princ)
  141. )
  142.  
  143. ; Generate a sphere or a hemisphere (dome/dish)
  144. (defun DOMSPH (which / cen e elev h h1 h2 max-rad min-rad numseg rad)
  145.    (varget)
  146.    (setvar "THICKNESS" 0)
  147.    (setvar "CMDECHO"   0)
  148.    (setvar "HIGHLIGHT" 0)
  149.    (initget (+ 1 16))                 ; Center point - 3d okay, cannot be null
  150.    (setq cen (getpoint "\nCenter point: "))
  151.    (initget 7)                        ; Radius cannot be zero, neg, or null
  152.    (setq rad (getdist cen "\nRadius: "))
  153.    (setvar "BLIPMODE" 0)
  154.    (initget 6)                        ; Cannot have zero or negative segs
  155.    (setq numseg (getint "\nNumber of segments <15>: "))
  156.    (if (null numseg)
  157.        (setq numseg 15)
  158.    )
  159.    (setq e (entlast))                 ; Take database checkpoint
  160.    (if (= (logand which 1) 1)         ; If sphere or dome,
  161.        (hemisphere "upper")           ;   do upper hemisphere
  162.    )
  163.    (if (= (logand which 2) 2)         ; If sphere or dish,
  164.        (hemisphere "lower")           ;   do lower hemisphere
  165.    )
  166.    (command "ARRAY" (selstuff e) "" "Polar" cen numseg "360" "")
  167.    (resetvar)
  168. )
  169.  
  170. ; Draw a 3D dome (upper hemisphere)
  171. (defun C:DOME ()
  172.    (domsph 1)
  173. )
  174.  
  175. ; Draw a 3D dish (lower hemisphere)
  176. (defun C:DISH ()
  177.    (domsph 2)
  178. )
  179.  
  180. ; Draw a sphere
  181. (defun C:SPHERE ()
  182.    (domsph 3)
  183. )
  184.  
  185. ; Draw a torus
  186. (defun C:TORUS ()
  187.    (varget)
  188.    (setvar "THICKNESS" 0)
  189.    (setvar "CMDECHO"   0)
  190.    (setvar "HIGHLIGHT" 0)
  191.    (initget (+ 1 16))                 ; Center point - 3D okay, cannot be null
  192.    (setq cen (getpoint "\nCenter point: "))
  193.    (initget 7)                        ; Radius cannot be zero, neg, or null
  194.    (setq radl (getdist cen "\nLarge radius: "))
  195.    (initget 7)
  196.    (initget 6)                        ; Cannot have zero or negative segs
  197.    (setq numlseg (getint "\nNumber of segments <15>: "))
  198.    (if (null numlseg)
  199.        (setq numlseg 15)
  200.    )
  201.    (setq rads (getdist cen "\nSmall radius: "))
  202.    (setvar "BLIPMODE" 0)
  203.    (initget 6)                        ; Cannot have zero or negative segs
  204.    (setq numsseg (getint "\nNumber of segments <15>: "))
  205.    (if (null numsseg)
  206.        (setq numsseg 15)
  207.    )
  208.    (setq e (entlast))                 ; Take database checkpoint
  209.    (setq deltas (* 2.0 (/ pi numsseg)))
  210.    (setq deltal (* 2.0 (/ pi numlseg)))
  211.    (setq cosa (cos deltal))
  212.    (setq sina (sin deltal))
  213.    (setq xorg (car cen))
  214.    (setq yorg (cadr cen))
  215.    (if (null (setq zorg (caddr cen)))
  216.       (setq zorg (getvar "ELEVATION"))
  217.    )   
  218.    (setq x (+ radl rads))
  219.    (setq px1 (+ x xorg))
  220.    (setq py1 yorg)
  221.    (setq pz1 zorg)
  222.    (setq px2 (+ xorg (* x cosa)))
  223.    (setq py2 (+ yorg (* x sina)))
  224.    (setq pz2 pz1)
  225.    (command "3DFACE"
  226.       (list px1 py1 pz1)
  227.       (list px2 py2 pz2)
  228.    )
  229.    (setq j 1)
  230.    (setq flop 0)
  231.    (while (<= j numsseg)
  232.       (setq beta (* j deltas))
  233.       (setq x (+ radl (* rads (cos beta))))
  234.       (setq px3 (+ xorg (* x cosa)))
  235.       (setq py3 (+ yorg (* x sina)))
  236.       (setq pz3 (+ zorg (* rads (sin beta))))
  237.       (setq px4 (+ xorg x))
  238.       (setq py4 yorg)
  239.       (setq pz4 pz3)
  240.       (if (= 1 flop)
  241.          (command 
  242.             (list px4 py4 pz4)
  243.             (list px3 py3 pz3)
  244.          )
  245.          (command 
  246.             (list px3 py3 pz3)
  247.             (list px4 py4 pz4)
  248.          )
  249.       )
  250.       (setq flop (- 1 flop))
  251.       (setq j (+ j 1))
  252.    )
  253.    (command "")
  254.    (command "ARRAY" (selstuff e) "" "Polar" cen numlseg "360" "Y")
  255. )
  256.